home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 013 / td3.arc / TD.LIB < prev    next >
Encoding:
Text File  |  1986-03-18  |  5.8 KB  |  214 lines

  1.  
  2. { Turbodraw library  ( PC version ) }
  3.  
  4. { 3/18/86 - Added sound to signal keying errors }
  5.  
  6. type
  7.     stype = string[20];
  8.  
  9. const
  10.     ctlh = ^H;   { Backspace }
  11.     ctlm = ^M;   {  Return   }
  12.  
  13.  
  14. function getnum(p,q:integer):stype;    { 12/19/84 }
  15.  
  16. { Called by: GETINT(P) and GETREAL(p,q)                      }
  17.  
  18. { Getnum allows entry of a number of Scale P and Precision Q }
  19. { The operator is not allowed to enter a number with greater }
  20. { precision and/or scale.  Character delete using the back-  }
  21. { space key can be used.                                     }
  22.  
  23. var
  24.     i      : integer;
  25.     number : stype;       { Input buffer }
  26.     digit  : char;
  27.     frac   : integer;
  28.     dp     : boolean;
  29.  
  30. begin
  31.     I:=1;
  32.     Dp:=false;
  33.     Frac:=0;
  34.     Digit:=' ';
  35.     Number:=' ';
  36.  
  37.     while Digit <> ctlm do
  38.         begin          { don't exit until a CR is entered }
  39.         read(kbd,digit);
  40.         write(digit);
  41.         If Digit=ctlh Then { backspace }
  42.             If I > 1 Then
  43.                 begin
  44.                 I:=I-1;
  45.                 If Dp=TRUE Then Frac:=Frac-1;
  46.                 If Copy(Number,I,1)='.' Then
  47.                     begin     { special handling for decimal point }
  48.                     Dp:=FALSE;
  49.                     Frac:=0   { just to make sure its at zero    }
  50.                 End;
  51.                 number:=copy(number,1,i-1)+' '+copy(number,i+1,20);
  52.                 write(' ' + ctlh)     { Delete character on screen }
  53.             End
  54.             Else { If I>1 }
  55.             begin
  56.                 sound(600);
  57.                 delay(10);
  58.                 nosound;
  59.                 write(' ');  { put cursor back }
  60.             end;
  61.             If Digit='-' Then
  62.                 If I = 1 Then
  63.                     begin
  64.                     number:=copy(number,1,i-1)+digit+copy(number,i+1,20);
  65.                     I:=I+1;
  66.                 End
  67.                 Else
  68.                     Digit:=' ';
  69.             if digit in ['0'..'9'] then
  70.                 begin;
  71.                 If Dp=TRUE Then { we are past decimal point }
  72.                     begin
  73.                     if (I=P+2) or (Frac = q) Then
  74.                     begin
  75.                         sound(200);
  76.                         delay(10);
  77.                         nosound;
  78.                         write(ctlh + ' ' + ctlh);  { At full prec. }
  79.                     end
  80.                     Else
  81.                         begin
  82.                         number:=copy(number,1,i-1)+digit+copy(number,i+1,20);
  83.                         Frac:=Frac+1;
  84.                         I:=I+1;
  85.                     End
  86.                 End
  87.                 Else    { If DP }
  88.                 If I=P-Q+1 Then   { allow only a '.' }
  89.                 begin
  90.                     sound(200);
  91.                     delay(10);
  92.                     nosound;
  93.                     write(ctlh + ' ' + ctlh);
  94.                 end
  95.                 Else
  96.                     begin
  97.                     number:=copy(number,1,i-1)+digit+copy(number,i+1,20);
  98.                     I:=I+1;
  99.                 End;
  100.  
  101.             End                   { If verify }
  102.             Else
  103.             If Digit='.' Then
  104.                 If Dp=FALSE Then { only one decimal per number }
  105.                     begin
  106.                     number:=copy(number,1,i-1)+'.'+copy(number,i+1,20);
  107.                     I:=I+1;
  108.                     Dp:=TRUE;
  109.                 End
  110.                 Else
  111.                 begin
  112.                   sound(600);
  113.                   delay(10);
  114.                   nosound;
  115.                   Digit:=' ';  { eliminate extra decimal point }
  116.                 end;
  117.                 if not (digit in ['-','0'..'9','.',ctlh,ctlm]) then
  118.                 begin
  119.                     sound(600);
  120.                     delay(10);
  121.                     nosound;
  122.                     write(ctlh + ' ' + ctlh);
  123.                 end;
  124.             End;  { Do While }
  125.  
  126.            getnum:=number;
  127.        end;
  128.  
  129. function getreal(len,scale : integer) : real;
  130.  
  131. { GETREAL returns a number of max length LEN }
  132. { and max scale SCALE                        }
  133.  
  134. var
  135.    i,j,temp,sign  : integer;
  136.    result         : real;
  137.    digit          : char;
  138.    num            : stype;
  139.    code           : integer;
  140.  
  141. begin
  142.    num:=getnum(len,scale);
  143.    i:=length(num);
  144.    j:=1;
  145.    sign:=1;
  146.    while i > 0 do
  147.        begin
  148.        digit:=copy(num,i,1);
  149.        i:=i-1;
  150.        case digit of
  151.            '0'..'9' : begin
  152.                          val(digit,temp,code);
  153.                          result:=result+(temp*j);
  154.                          j:=j*10;
  155.                       end;
  156.            '-'      : sign:=-1;
  157.            '.'      : begin
  158.                          result:=result/j;
  159.                          j:=1;
  160.                       end;
  161.         end;
  162.     end;
  163.     getreal:=result*sign;
  164. end;
  165.  
  166. function getint(len : integer) : integer;
  167.  
  168. { GETINT returns a number of max length LEN and }
  169. { a scale of zero ( integer )                   }
  170.  
  171. var
  172.    result,code : integer;
  173.    num         : stype;
  174.  
  175. begin
  176.    val(getnum(len,0),result,code);
  177.    getint:=result;
  178. end;
  179.  
  180. { HEX support functions and procedures }
  181.  
  182. function tohex(nibble : integer) : char;  { convert 1/2 byte to hex 0-F }
  183. begin
  184.     if nibble > 9 then
  185.         tohex:=chr(nibble+55)
  186.     else
  187.         tohex:=chr(nibble+48);
  188. end;
  189.  
  190. procedure prbyte(num : byte); { display a byte as a two digit hex number }
  191. var
  192.   num1      : integer;
  193.   nibl,nib2 : integer;
  194.   c         : char;
  195.  
  196. begin
  197.     num1:=num;
  198.     nibl:=trunc(num1/16);
  199.     write(tohex(nibl));
  200.     nib2:=num1-(nibl*16);
  201.     write(tohex(nib2));
  202.  end;
  203.  
  204. procedure prword(num : integer); { display integer as 4 digit hex number }
  205. var
  206.   bt1,bt2 : byte;
  207.  
  208. begin
  209.     bt1:=(trunc(num/256));
  210.     bt2:=(num-(bt1*256));
  211.     prbyte(bt1);
  212.     prbyte(bt2);
  213. end;
  214.